CICA 1993 April/CICA MS Windows - April 1993.iso/unzipped/programr/tp/dnd/papdrop.pas

Pascal/Delphi Source File | 1992-04-30 | 6KB | 246 lines

Program PaperDrop;

{ Drop a bmp on us and it becomes the wallpaper! }

{$R-,I-,G+,W-,S-,D-,L-}

{$R PAPDROP}

Uses
 WinTypes,WinProcs,Win31,ShellAPI,WObjects,Strings;

Const
  AppName = 'Paper Drop';
  cm_TileCent = 101;

Type
  PPaperWin = ^TPaperWin;
  TPaperWin = Object(TWindow)
                PixMode : Integer;
                hSysMenu : HMenu;

                Procedure SetupWindow;
                  Virtual;

                Function GetClassName : PChar;
                  Virtual;

                Procedure GetWindowClass(Var AWndClass : TWndClass);
                  Virtual;

                Procedure WMQueryOpen(Var Msg : TMessage);
                  Virtual wm_QueryOpen;

                Procedure WMDropFiles(var Msg : TMessage);
                  Virtual wm_first + wm_DropFiles;

                Procedure FileDropped(FileName : PChar;
                                      Var DropPos : TPoint;
                                      InClient : Boolean);
                  Virtual;

                Procedure WMSysCommand(Var Msg : TMessage);
                  Virtual wm_SysCommand;

                Procedure CMTileCent(Var Msg : TMessage);
                  Virtual cm_First + cm_TileCent;

              End;

 TMyApp = Object(TApplication)
            Procedure InitMainWindow;
              Virtual;
          End;

{---------------------------------------------------}

{ --- Utility Procedures --- }

{ Toggle a checkmark menu item on or off }

Procedure ToggleCheck(Menu : HMenu; MenuItemID : Word);

Var
  MAttr,WCheck : Word;

Begin
  MAttr := GetMenuState(Menu,MenuItemID,mf_ByCommand);

  If (MAttr and mf_Checked) = mf_Checked
    Then WCheck := mf_ByCommand Or mf_Unchecked
    Else WCheck := mf_ByCommand Or mf_Checked;

  CheckMenuItem(Menu,MenuItemID,WCheck);
End {ToggleCheck};

{---------------------------------------------------}

{ --- Application Methods --- }

Procedure TMyApp.InitMainWindow;

Begin
  MainWindow := New(PPaperWin,Init(nil,AppName));
End;

{---------------------------------------------------}

{ --- Window Methods --- }

Procedure TPaperWin.SetupWindow;

Begin
  TWindow.SetupWindow;

  { Inform Windows that we accept file drops }
  DragAcceptFiles(hWindow,True);

  { Add our menu choice to system menu }
  hSysMenu := GetSystemMenu(HWindow,False);

  AppendMenu(hSysMenu,mf_Separator,0,Nil);
  AppendMenu(hSysMenu,mf_String,cm_TileCent,'&Tile Wallpaper');

  { Set initial state of menu checkmark }
  PixMode := GetProfileInt('Desktop','TileWallpaper',1);
  If PixMode = 1
    Then CheckMenuItem(hSysMenu,cm_TileCent,mf_ByCommand Or mf_Checked);

End {SetupWindow};

{---------------------------------------------------}

Procedure TPaperWin.WMDropFiles;

Var
 NumFiles : word;
 FileName : array[0..127] of char;
 i : word;
 DropPoint : TPoint;
 InClientArea : boolean;

Begin
 { Msg.wParam contains a handle to the "drop info" }

 { First, find out how many files were dropped }
 NumFiles := DragQueryFile(Msg.wParam,$FFFF,Nil,0);

 { Error if more than 1 was dropped }
 If NumFiles > 1
   Then MessageBox(HWindow,'You Can Only Have one Wallpaper Bitmap at a Time!',
                           'Paper Drop Error',mb_Ok or Mb_IconExclamation);

 { Next, find out where the file was dropped }
 InClientArea := DragQueryPoint(Msg.wParam,DropPoint);

 { Retrieve the dropped file and call the virtual method "FileDropped" }
 DragQueryFile(Msg.wParam,0,FileName,Pred(Sizeof(FileName)));
 FileDropped(FileName,DropPoint,InClientArea);

 { Cleanup - tell Windows that we're done with the "drop info" }
 DragFinish(Msg.wParam);

End {WMDropFiles};

{---------------------------------------------------}

Procedure TPaperWin.FileDropped(FileName : PChar;
                                       Var DropPos : TPoint;
                                       InClient : Boolean);

Var
  PaperFile : File;
  Tx : Array [0..80] of Char;
  Res : Word;

Begin
  { Check for the proper type of file }
  If (StrPos(FileName,'.BMP') = Nil) And
     (StrPos(FileName,'.RLE') = Nil)
   Then MessageBox(HWindow,'Pteui!  Bleah!  I can Only Load Bitmaps, Buster',
                           'Paper Drop Error',mb_Ok or Mb_IconExclamation)

   Else { Set the wallpaper and update WIN.INI }
        SystemParametersInfo(spi_SetDeskWallpaper,0,FileName,spif_UpdateIniFile);
End {FileDropped};

{---------------------------------------------------}

Procedure TPaperWin.WMQueryOpen(Var Msg : TMessage);

Begin
  Msg.Result := 0;       { Deny open }
End {WMQueryOpen};

{---------------------------------------------------}

Function TPaperWin.GetClassName;

Begin
  GetClassName := AppName;
End {GetClassName};

{---------------------------------------------------}

Procedure TPaperWin.GetWindowClass(Var AWndClass : TWndClass);

Begin
  TWindow.GetWindowClass(AWndClass);

  AWndClass.hIcon := LoadIcon(HInstance,'_PAPER');
End {GetWindowClass};

{---------------------------------------------------}

Procedure TPaperWin.WMSysCommand(Var Msg : TMessage);

Begin
  Case Msg.wParam of
    cm_TileCent : CMTileCent(Msg);
    Else DefWndProc(Msg);
  End;
End {WMSysCommand};

{---------------------------------------------------}

{ --- Menu Response Methods --- }

Procedure TPaperWin.CMTileCent(Var Msg : TMessage);

Var
  PixModeStr : Array [0..2] of Char;

Begin
  { Get center/tile option }
  PixMode := GetProfileInt('Desktop','TileWallpaper',1);

  { Invert it }
  If PixMode = 1
    Then PixMode := 0
    Else PixMode := 1;

  Str(PixMode,PixModeStr);

  ToggleCheck(hSysMenu,cm_TileCent);

  { Write it out }
  WriteProfileString('Desktop','TileWallpaper',PixModeStr);

  { Redraw desktop }
  SystemParametersInfo(spi_SetDeskWallpaper,0,Nil,0);

End {CMTileCent};

{---------------------------------------------------}

Var
  MyApp : TMyApp;

Begin
  CmdShow := sw_ShowMinNoActive;

  MyApp.Init(AppName);
  MyApp.Run;
  MyApp.Done;
End.